home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / fools.lzh / pp.scm < prev    next >
Text File  |  1990-03-02  |  8KB  |  281 lines
  1. ;;; pretty print scheme expressions
  2.  
  3. (provide 'pp)
  4. (in-package 'pp)
  5.  
  6. ; list of printers (initialized at the bottom)
  7. (define *printer-list* nil)
  8.  
  9. ; number of columns to print within
  10. (define *print-columns* 75)
  11.  
  12. ; indentation within special forms
  13. (define *special-indent* 2)
  14.  
  15. (define (top-level:pretty-print expr . file)
  16.   (let ((file (if (null? file) (current-output-port) (car file)))
  17.     (expr (if (eq? (object-type expr) 'lambda)
  18.           (code-body expr)
  19.           expr)))
  20.     (print-expr expr 0 file)
  21.     (newline file)
  22.     #t))
  23.  
  24. (define (top-level:pp expr)
  25.   ;; assume symbol == macro-name
  26.   (pretty-print (if (symbol? expr) (macro expr) expr)))
  27.  
  28. ;; counters
  29. (define (make-cnt depth) (box (- *print-columns* depth)))
  30. (define cnt-val unbox)
  31. (define cnt-set! set-box!)
  32. (define (cnt-zero? cnt) (<= (cnt-val cnt) 0))
  33. (define (cnt-sub cnt val) (>= (cnt-set! cnt (- (cnt-val cnt) val)) 0))
  34.  
  35. (define (abbrev expr)
  36.   ;; check for quote, quasiquote, ... forms
  37.   (if (and (pair? expr) (pair? (cdr expr)) (null? (cddr expr)))
  38.       (let ((which (memq (car expr)
  39.              '(unquote unquote-splicing quote quasiquote))))
  40.     (if which (car which)))))
  41.  
  42. (define (fit? expr cnt)
  43.   ;; #t if expr will fit within the space provided by cnt
  44.   (case (object-type expr)
  45.     (symbol (cnt-sub cnt (string-length expr)))
  46.     (string (cnt-sub cnt (+ 2 (string-length expr))))
  47.     ((null true false) (cnt-sub cnt 2))
  48.     (pair
  49.      (let ((h (car expr))
  50.        (t (cdr expr))
  51.        (q (abbrev expr)))
  52.        (if q
  53.        (and (cnt-sub cnt (if (eq? q 'unquote-splicing) 2 1))
  54.         (fit? (car t) cnt))
  55.        (cond ((null? t)
  56.           (and (cnt-sub cnt 2) (fit? h cnt)))
  57.          ((pair? t)
  58.           (and (cnt-sub cnt 1)
  59.                (fit? h cnt)
  60.                (fit? t cnt)))
  61.          (else
  62.           (and (cnt-sub cnt 5)
  63.                (fit? h cnt)
  64.                (fit? t cnt)))))))
  65.     (integer (cnt-sub cnt (string-length (integer->string expr #\d))))
  66.     (vector
  67.      (letrec ((vlen (- (vector-length expr) 1))
  68.           (vloop
  69.            (lambda (ptr)
  70.          (if (< ptr vlen)
  71.              (cnt-sub cnt 3)
  72.              (and (fit? (vector-ref expr ptr) cnt)
  73.               (vloop (+ ptr 1)))))))
  74.        (vloop 0)))
  75.     (end-of-file (cnt-sub cnt 5))
  76.     (character
  77.      (cnt-sub cnt
  78.           (case expr
  79.         (#\newline 9)
  80.         (#\tab 5)
  81.         (#\space 7)
  82.         ; assumes no other unprintable characters
  83.         (else 3))))
  84.     (box
  85.      (and (cnt-sub cnt 2)
  86.       (fit? (unbox expr) cnt)))
  87.     (else
  88.      (cnt-sub cnt (string-length (->string expr #t))))))
  89.     
  90. (define (indent x file)
  91.   ;; indent by x spaces
  92.   (cond ((<= x 0) #t)
  93.     ((>= x *print-columns*) #t)
  94.     ((>= x 8) (write-char #\tab file) (indent (- x 8) file))
  95.     (else (write-char #\space file) (indent (- x 1) file))))
  96.  
  97. (define (print-expr expr depth file)
  98.   (if (and (pair? expr) (not (fit? expr (make-cnt depth))))
  99.       (if (and (not (pair? (car expr))) (list? expr))
  100.       (let ((printer (assq (car expr) *printer-list*)))
  101.         (if printer
  102.         ((cdr printer) expr depth file)
  103.         (print-op expr depth file)))
  104.       (print-list expr depth file))
  105.       (write expr file)))
  106.  
  107. (define (print-op expr depth file)
  108.   (write-char #\( file)
  109.   (print-expr (car expr) depth file)
  110.   (set! depth (+ depth 2 (string-length (car expr))))
  111.   (when (pair? (cdr expr))
  112.     (write-char #\space file)
  113.     (print-expr (cadr expr) depth file)
  114.     (for-each (lambda (expr)
  115.         (newline file)
  116.         (indent depth file)
  117.         (print-expr expr depth file))
  118.           (cddr expr)))
  119.   (write-char #\) file))
  120.  
  121. (define (print-list lst depth file)
  122.   (letrec ((loop
  123.         (lambda (first? lst)
  124.           (cond ((null? lst) #t)
  125.             ((not (pair? lst))
  126.              (fdisplay file " . ")
  127.              (print-expr lst (+ depth 3) file))
  128.             (else
  129.              (unless first?
  130.                (newline file)
  131.                (indent depth file))
  132.              (print-expr (car lst) depth file)
  133.              (loop #f (cdr lst)))))))
  134.     (write-char #\( file)
  135.     (set! depth (+ depth 1))
  136.     (loop #t lst)
  137.     (write-char #\) file)))
  138.  
  139. (define (print-clause clause depth file)
  140.   ; generic clause/binding printer
  141.   (if (fit? clause (make-cnt depth))
  142.       (write clause file)
  143.       (begin
  144.     (write-char #\( file)
  145.     (set! depth (+ depth 1))
  146.     (print-expr (car clause) depth file)
  147.     (for-each (lambda (expr)
  148.             (newline file)
  149.             (indent depth file)
  150.             (print-expr expr depth file))
  151.           (cdr clause))
  152.     (write-char #\) file))))
  153.  
  154. (define (print-let expr depth file)
  155.   ; print (let[rec] [name] bindings . body)
  156.   (let ((cdepth (+ depth 3 (string-length (car expr))))
  157.     (bindings (cadr expr))
  158.     (body (cddr expr))
  159.     (first? #t))
  160.     (fdisplay file "(" (car expr))
  161.     (if (symbol? bindings) ; named let
  162.     (begin (fdisplay file " " bindings)
  163.            (set! cdepth (+ cdepth 1 (string-length bindings)))
  164.            (set! bindings (caddr expr))
  165.            (set! body (cdr body))))
  166.     (display " (" file)
  167.     (for-each (lambda (clause)
  168.         (if first?
  169.             (set! first? #f)
  170.             (begin (newline file) (indent cdepth file)))
  171.         (print-clause clause cdepth file))
  172.           bindings)
  173.     (write-char #\) file)
  174.     (set! depth (+ depth *special-indent*))
  175.     (for-each (lambda (expr)
  176.         (newline file) (indent depth file)
  177.         (print-expr expr depth file))
  178.           body)
  179.     (write-char #\) file)))
  180.  
  181. (define (print-cond expr depth file)
  182.   ; print (cond . clauses)
  183.   (let ((first? #t))
  184.     (write-char #\( file)
  185.     (display (car expr) file)
  186.     (write-char #\space file)
  187.     (set! depth (+ depth 2 (string-length (car expr))))
  188.     (for-each (lambda (clause)
  189.         (if first?
  190.             (set! first? #f)
  191.             (begin (newline file) (indent depth file)))
  192.         (print-clause clause depth file))
  193.           (cdr expr))
  194.     (write-char #\) file)))
  195.  
  196. (define (print-case expr depth file)
  197.   (write-char #\( file)
  198.   (display (car expr) file)
  199.   (write-char #\space file)
  200.   (display (cadr expr) file)
  201.   (set! depth (+ depth *special-indent*))
  202.   (for-each (lambda (clause)
  203.           (newline file)
  204.           (indent depth file)
  205.           (print-clause clause depth file))
  206.         (cdr expr))
  207.   (write-char #\) file))
  208.  
  209. (define (print-sform expr depth file)
  210.   ; print (sform arg . body)
  211.   (fdisplay file #\( (car expr) #\space (cadr expr))
  212.   (set! depth (+ depth *special-indent*))
  213.   (for-each (lambda (arg)
  214.           (newline file)
  215.           (indent depth file)
  216.           (print-expr arg depth file))
  217.         (cddr expr))
  218.   (write-char #\) file))
  219.  
  220. (define (print-sform0 expr depth file)
  221.   ; print (sform . body)
  222.   (fdisplay file #\( (car expr))
  223.   (set! depth (+ depth *special-indent*))
  224.   (for-each (lambda (arg)
  225.           (newline file)
  226.           (indent depth file)
  227.           (print-expr arg depth file))
  228.         (cdr expr))
  229.   (write-char #\) file))
  230.           
  231. (define (print-quote expr depth file)
  232.   ; print (quote arg)
  233.   (if (and (pair? (cdr expr)) (null? (cddr expr)))
  234.       (begin
  235.     (write-char #\' file)
  236.     (print-expr (cadr expr) (+ depth 1) file))
  237.       (write expr file)))
  238.  
  239. (define (print-quasi expr depth file)
  240.   ; print (quasiquote|unquote|unquote-splicing arg)
  241.   (let ((which (abbrev expr)))
  242.     (if which
  243.     (let ((arg (cadr expr)))
  244.       (case which
  245.         (quasiquote (write-char #\` file))
  246.         (unquote (write-char #\, file))
  247.         (else (display ",@" file)))
  248.       (if (pair? arg)
  249.           (print-list arg
  250.               (+ depth (if (eq? which 'unquote-splicing) 2 1))
  251.               file)
  252.           (write arg file)))
  253.     (print-op expr depth file))))
  254.  
  255. (define (printer-add form printer)
  256.   ; add pretty printers
  257.   (set! *printer-list* (cons (cons form printer) *printer-list*))
  258.   #t)
  259.  
  260. (printer-add 'lambda print-sform)
  261. (printer-add 'define print-sform)
  262. (printer-add 'define-macro print-sform)
  263. (printer-add 'define-expander print-sform)
  264. (printer-add 'extend-syntax print-sform)
  265. (printer-add 'cond print-cond)
  266. (printer-add 'let print-let)
  267. (printer-add 'letrec print-let)
  268. (printer-add 'let* print-let)
  269. (printer-add 'do print-let)
  270. (printer-add 'quote print-quote)
  271. (printer-add 'quasiquote print-quasi)
  272. (printer-add 'unquote print-quasi)
  273. (printer-add 'unquote-splicing print-quasi)
  274. (printer-add 'call-with-current-continuation print-sform0)
  275. (printer-add 'call/cc print-sform0)
  276. (printer-add 'case print-case)
  277. (printer-add 'record-case print-case)
  278. (printer-add 'when print-sform)
  279. (printer-add 'unless print-sform)
  280. (printer-add 'while print-sform)
  281.